home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / kpascal.com / EDITCOLO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-12-06  |  8.0 KB  |  288 lines
  1. Program ColorEditor;
  2.  
  3. uses Crt,
  4.      KPascal, Keyboard, Colors;
  5.  
  6. var
  7.    tf : boolean;
  8.  
  9.  
  10. Procedure GetNewChar( var TheChar : char );
  11. var
  12.    ch   : char;
  13.    func : boolean;
  14. Begin
  15.      Say( 90,12, a_pr+ 'Enter the new character or ESC to quit.' );
  16.      repeat
  17.         ch := GetKey( func );
  18.      until (ch <> #00);
  19.      if (ch <> #27) and (not func) then TheChar := ch;
  20. End;
  21.  
  22.  
  23. Procedure DisplayColors( blinking : boolean );
  24. var
  25.    cntrX, cntrY,
  26.    colornum,
  27.    x, y       : byte;
  28. Begin
  29.      x := 18;
  30.      y := 5;
  31.      if (blinking)
  32.        then colornum := 128
  33.        else colornum := 0;
  34.      for cntrY := 1 to 8
  35.        do begin
  36.           for cntrX := 1 to 16
  37.             do begin
  38.                Say( x,y, SayAttr( colornum )+ '*' );
  39.                Inc( x, 3 );
  40.                Inc( colornum );
  41.             end;
  42.           Inc( y, 2 );
  43.           x := 18;
  44.        end;
  45. End;
  46.  
  47.  
  48. Procedure SquareColor( ColorNum : byte );
  49. var
  50.    col,
  51.    line  : integer;
  52. Begin
  53.      line :=(((ColorNum div 16) + 1) * 2) + 3;
  54.      col := (((ColorNum mod 16) + 1) * 3) + 15;
  55.      Say( col-1, line-1, '`a007'+'┌─┐' );
  56.      Say( col-1, line+1, '`a007'+'└─┘' );
  57. End;
  58.  
  59. Procedure UnSquareColor( ColorNum : byte );
  60. var
  61.    col,
  62.    line  : integer;
  63. Begin
  64.      line :=(((ColorNum div 16) + 1) * 2) + 3;
  65.      col := (((ColorNum mod 16) + 1) * 3) + 15;
  66.      Say( col-1, line-1, SayAttr(a_back)+'   ' );
  67.      Say( col-1, line+1, SayAttr(a_back)+'   ' );
  68. End;
  69.  
  70.  
  71. Procedure GetNewColor( var ColorNum : byte );
  72. var
  73.    old,
  74.    new  : integer;
  75.    ch   : char;
  76.    blinking,
  77.    func,
  78.    done : boolean;
  79. Begin
  80.      if (ColorNum > 127)
  81.        then begin
  82.           new := ColorNum - 128;
  83.           blinking := true;
  84.        end
  85.        else begin
  86.           new := ColorNum;
  87.           blinking := false;
  88.        end;
  89.      DisplayColors( blinking );
  90.      Say( 90,24, 'Press Left/Right/Up/Down arrows to change color' );
  91.      Say( 90,25, 'Press the "+" key to turn blinking on/off' );
  92.      done := false;
  93.      repeat
  94.         SquareColor( new );
  95.         repeat
  96.            ch := GetKey( func );
  97.         until (ch <> #00);
  98.         old := new;
  99.         case func of
  100.            true : case ch of
  101.                     #72 : Dec( new, 16 );  {up}
  102.                     #80 : Inc( new, 16 );  {down}
  103.                     #77 : Inc( new );      {right}
  104.                     #75 : Dec( new );     {left}
  105.                   end;
  106.           false : case ch of
  107.                     #13 : done := true;
  108.                     #27 : done := true;
  109.                     '+' : blinking := not blinking;
  110.                   end;
  111.         end;
  112.         UnSquareColor( old );
  113.         if (new < 0) then Inc( new, 128 );
  114.         if (new > 127) then Dec( new, 128 );
  115.      until done;
  116.      if (ch <> #27)
  117.        then begin
  118.           if (blinking)
  119.             then ColorNum := new + 128
  120.             else ColorNum := new;
  121.        end;
  122. End;
  123.  
  124.  
  125. Function AttrByte( theAttr : AttrStr ) : byte;
  126. var
  127.    Cbyte : byte;
  128.    err   : integer;
  129. Begin
  130.      Val( Copy(theAttr,3,3), Cbyte, err );
  131.      if (err = 0)
  132.        then AttrByte := Cbyte
  133.        else AttrByte := 0;
  134. End;
  135.  
  136.  
  137. Procedure DisplayList;
  138. const
  139.      col = 25;
  140. var
  141.    line : byte;
  142. Begin
  143.      line := 5;
  144.      Say( col,line, a_mh+'A. '+a_dh+'Highlighted Data' );
  145.      Inc( line );
  146.      Say( col,line, a_mh+'B. '+a_dl+'Normal Data' );
  147.      Inc( line );
  148.      Say( col,line, a_mh+'C. '+a_mh+'Highlighted Menu Character' );
  149.      Inc( line );
  150.      Say( col,line, a_mh+'D. '+a_ml+'Normal Menu Characters' );
  151.      Inc( line );
  152.      Say( col,line, a_mh+'E. '+a_ms+'Selected Menu Item' );
  153.      Inc( line );
  154.      Say( col,line, a_mh+'F. '+a_mn+'Not Selected Menu Item' );
  155.      Inc( line );
  156.      Say( col,line, a_mh+'G. '+a_st+'Status Line Data' );
  157.      Inc( line );
  158.      Say( col,line, a_mh+'H. '+a_pr+'Input Prompt Question' );
  159.      Inc( line );
  160.      Say( col,line, a_mh+'I. '+a_border+'Border Colors' );
  161.      Inc( line );
  162.      Say( col,line, a_mh+'J. '+a_tm+'Time/Date Colors' );
  163.      Inc( line );
  164.      Say( col,line, a_mh+'K. '+a_err+'Error Messages' );
  165.      Inc( line );
  166.      Say( col,line, a_mh+'L. '+a_ins+'Insert On/Off Display' );
  167.      Inc( line );
  168.      Say( col,line, a_mh+'M. '+a_inp+'Input Editing Field' );
  169.      Inc( line );
  170.      Say( col,line, a_mh+'N. '+a_inp+'Input Editing Character: '+fieldblank );
  171.      Inc( line );
  172.      Say( col,line, a_mh+'O. '+a_ed+'Input Field After Editing' );
  173.      Inc( line );
  174.      Say( col,line, a_mh+'P. Background Color: '+SayAttr(a_back)+'BACKGROUND' );
  175.      Inc( line );
  176.      Say( 90,25, 'ESC to quit' );
  177. End;
  178.  
  179.  
  180. Procedure GetWhatToDo;
  181. var
  182.    ColorByte : byte;
  183.    ch        : char;
  184.    func,
  185.    quit      : boolean;
  186. Begin
  187.      quit := false;
  188.      repeat
  189.         ClrScr;
  190.         DisplayList;
  191.         repeat
  192.            ch := GetKey( func );
  193.         until (ch <> #00);
  194.         ClrScr;
  195.         case UpCase(ch) of
  196.            #27 : quit := true;
  197.            'A' : begin
  198.                     ColorByte := AttrByte( a_dh );
  199.                     GetNewColor( ColorByte );
  200.                     a_dh := SayAttr( ColorByte );
  201.                  end;
  202.            'B' : begin
  203.                     ColorByte := AttrByte( a_dl );
  204.                     GetNewColor( ColorByte );
  205.                     a_dl := SayAttr( ColorByte );
  206.                  end;
  207.            'C' : begin
  208.                     ColorByte := AttrByte( a_mh );
  209.                     GetNewColor( ColorByte );
  210.                     a_mh := SayAttr( ColorByte );
  211.                  end;
  212.            'D' : begin
  213.                     ColorByte := AttrByte( a_ml );
  214.                     GetNewColor( ColorByte );
  215.                     a_ml := SayAttr( ColorByte );
  216.                  end;
  217.            'E' : begin
  218.                     ColorByte := AttrByte( a_ms );
  219.                     GetNewColor( ColorByte );
  220.                     a_ms := SayAttr( ColorByte );
  221.                  end;
  222.            'F' : begin
  223.                     ColorByte := AttrByte( a_mn );
  224.                     GetNewColor( ColorByte );
  225.                     a_mn := SayAttr( ColorByte );
  226.                  end;
  227.            'G' : begin
  228.                     ColorByte := AttrByte( a_st );
  229.                     GetNewColor( ColorByte );
  230.                     a_st := SayAttr( ColorByte );
  231.                  end;
  232.            'H' : begin
  233.                     ColorByte := AttrByte( a_pr );
  234.                     GetNewColor( ColorByte );
  235.                     a_pr := SayAttr( ColorByte );
  236.                  end;
  237.            'I' : begin
  238.                     ColorByte := AttrByte( a_border );
  239.                     GetNewColor( ColorByte );
  240.                     a_border := SayAttr( ColorByte );
  241.                  end;
  242.            'J' : begin
  243.                     ColorByte := AttrByte( a_tm );
  244.                     GetNewColor( ColorByte );
  245.                     a_tm := SayAttr( ColorByte );
  246.                  end;
  247.            'K' : begin
  248.                     ColorByte := AttrByte( a_err );
  249.                     GetNewColor( ColorByte );
  250.                     a_err := SayAttr( ColorByte );
  251.                  end;
  252.            'L' : begin
  253.                     ColorByte := AttrByte( a_ins );
  254.                     GetNewColor( ColorByte );
  255.                     a_ins := SayAttr( ColorByte );
  256.                  end;
  257.            'M' : begin
  258.                     ColorByte := AttrByte( a_inp );
  259.                     GetNewColor( ColorByte );
  260.                     a_inp := SayAttr( ColorByte );
  261.                  end;
  262.            'N' : GetNewChar( fieldblank );
  263.            'O' : begin
  264.                     ColorByte := AttrByte( a_ed );
  265.                     GetNewColor( ColorByte );
  266.                     a_ed := SayAttr( ColorByte );
  267.                  end;
  268.            'P' : begin
  269.                     GetNewColor( a_back );
  270.                     TextAttr := a_back;
  271.                  end;
  272.         end;
  273.      until quit;
  274. End;
  275.  
  276.  
  277.  
  278. BEGIN
  279.      tf := GetColors( 'X' );
  280.      TextAttr := a_back;
  281.  
  282.      GetWhatToDo;
  283.      tf := SaveColors( 'X' );
  284.  
  285.      TextAttr := 07;
  286.      ClrScr;
  287. END.
  288.